home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1994 / MacHack 1994.toast / MacHack™ 1987-1994 / MacHack™ '93 / Papers '93 / Voice Toolkit / Voice Slot < prev    next >
Encoding:
Text File  |  1993-04-24  |  2.7 KB  |  89 lines  |  [TEXT/CCL2]
  1.  
  2. (in-package "VOICE-TOOLKIT")
  3.  
  4. (defclass voice-slot ()
  5.   ((contents :accessor contents
  6.              :initarg :contents)
  7.    (owner :accessor owner
  8.           :initarg :owner)
  9.    (text :accessor appear 
  10.          :initarg :text)
  11.    (careful :accessor careful
  12.             :initarg :careful
  13.             :initform t)
  14.    (text-color :accessor text-color)
  15.    (text-font :accessor text-font)))
  16.  
  17. (defmethod identify ((self voice-slot))
  18.   (file-voice-item self))
  19.  
  20. (defmethod exclusive ((self voice-slot))
  21.   (exclusive (owner self)))
  22.  
  23. (defmethod text ((self voice-slot))
  24.   (if (consp (appear self))
  25.     (format nil "~a ~{~a ~}"
  26.             (dialog-item-text (owner self))
  27.             (appear self))
  28.     (format nil "~a ~a" 
  29.             (dialog-item-text (owner self))
  30.             (appear self))))
  31.  
  32. (defmethod print-object ((self voice-slot) stream)
  33.   (format stream "~a" (appear self)))
  34.  
  35. (defmethod select ((self voice-slot))
  36.   (mark-item (owner self) (find-slot (owner self) self))
  37.   (if (dialog-item-action (owner self))
  38.     (funcall (dialog-item-action (owner self)))))
  39.  
  40. (defmethod mark ((self voice-slot))
  41.   (if (numberp *mark-method*)
  42.     (progn
  43.       (setf (text-color self)
  44.             (part-color (owner self)
  45.                         (make-point 0 (find-slot (owner self) self))))
  46.       (set-part-color (owner self) 
  47.                       (make-point 0 (find-slot (owner self) self))
  48.                       *mark-method*))
  49.     (progn
  50.       (setf (text-font self)
  51.             (cell-font (owner self)
  52.                        (make-point 0 (find-slot (owner self) self))))
  53.       (set-cell-font (owner self)
  54.                      (make-point 0 (find-slot (owner self) self))
  55.                      (list (first (view-font (owner self))) *mark-method*))))
  56.   (scroll-to-cell (owner self) (make-point 0 (find-slot (owner self) self)))
  57.   (view-draw-contents (owner self)))
  58.  
  59. (defmethod unmark ((self voice-slot))
  60.   (if (numberp *mark-method*)
  61.     (set-part-color (owner self)
  62.                     (make-point 0 (find-slot (owner self) self))
  63.                     (text-color self))
  64.     (set-cell-font (owner self)
  65.                    (make-point 0 (find-slot (owner self) self))
  66.                    (text-font self)))
  67.   (view-draw-contents (owner self)))
  68.  
  69. (defun in-slot (item slot)
  70.   (equal item (contents slot)))
  71.  
  72. (defun existing-slots (slots items)
  73.   (if slots
  74.     (if (member (contents (first slots)) items)
  75.       (cons (first slots) (existing-slots (rest slots) items))
  76.       (existing-slots (rest slots) items))))
  77.  
  78. (defun contents-of (item)
  79.   (if (equal (type-of item) 'voice-slot)
  80.     (contents item)
  81.     item))
  82.  
  83. (defun slot-values (slist)
  84.   (mapcar #'(lambda (s-item)
  85.               (if (equal (type-of s-item) 'voice-slot)
  86.                 (contents s-item)))
  87.           slist))
  88.  
  89.